home *** CD-ROM | disk | FTP | other *** search
/ SGI Freeware 1999 August / SGI Freeware 1999 August.iso / dist / fw_emacs.idb / usr / freeware / share / emacs / 19.34 / lisp / nnsoup.el.z / nnsoup.el
Encoding:
Text File  |  1998-10-28  |  24.0 KB  |  748 lines
  1. ;;; nnsoup.el --- SOUP access for Gnus
  2. ;; Copyright (C) 1995,96 Free Software Foundation, Inc.
  3.  
  4. ;; Author: Lars Magne Ingebrigtsen <larsi@ifi.uio.no>
  5. ;;     Masanobu UMEDA <umerin@flab.flab.fujitsu.junet>
  6. ;; Keywords: news, mail
  7.  
  8. ;; This file is part of GNU Emacs.
  9.  
  10. ;; GNU Emacs is free software; you can redistribute it and/or modify
  11. ;; it under the terms of the GNU General Public License as published by
  12. ;; the Free Software Foundation; either version 2, or (at your option)
  13. ;; any later version.
  14.  
  15. ;; GNU Emacs is distributed in the hope that it will be useful,
  16. ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  17. ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  18. ;; GNU General Public License for more details.
  19.  
  20. ;; You should have received a copy of the GNU General Public License
  21. ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  22. ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  23. ;; Boston, MA 02111-1307, USA.
  24.  
  25. ;;; Commentary:
  26.  
  27. ;;; Code:
  28.  
  29. (require 'nnheader)
  30. (require 'nnmail)
  31. (require 'gnus-soup)
  32. (require 'gnus-msg)
  33. (require 'nnoo)
  34. (eval-when-compile (require 'cl))
  35.  
  36. (nnoo-declare nnsoup)
  37.  
  38. (defvoo nnsoup-directory "~/SOUP/"
  39.   "*SOUP packet directory.")
  40.  
  41. (defvoo nnsoup-tmp-directory "/tmp/"
  42.   "*Where nnsoup will store temporary files.")
  43.  
  44. (defvoo nnsoup-replies-directory (concat nnsoup-directory "replies/")
  45.   "*Directory where outgoing packets will be composed.")
  46.  
  47. (defvoo nnsoup-replies-format-type ?n
  48.   "*Format of the replies packages.")
  49.  
  50. (defvoo nnsoup-replies-index-type ?n
  51.   "*Index type of the replies packages.")
  52.  
  53. (defvoo nnsoup-active-file (concat nnsoup-directory "active")
  54.   "Active file.")
  55.  
  56. (defvoo nnsoup-packer "tar cf - %s | gzip > $HOME/Soupin%d.tgz"
  57.   "Format string command for packing a SOUP packet.
  58. The SOUP files will be inserted where the %s is in the string.
  59. This string MUST contain both %s and %d. The file number will be
  60. inserted where %d appears.")
  61.  
  62. (defvoo nnsoup-unpacker "gunzip -c %s | tar xvf -"
  63.   "*Format string command for unpacking a SOUP packet.
  64. The SOUP packet file name will be inserted at the %s.")
  65.  
  66. (defvoo nnsoup-packet-directory "~/"
  67.   "*Where nnsoup will look for incoming packets.")
  68.  
  69. (defvoo nnsoup-packet-regexp "Soupout"
  70.   "*Regular expression matching SOUP packets in `nnsoup-packet-directory'.")
  71.  
  72.  
  73.  
  74. (defconst nnsoup-version "nnsoup 0.0"
  75.   "nnsoup version.")
  76.  
  77. (defvoo nnsoup-status-string "")
  78. (defvoo nnsoup-group-alist nil)
  79. (defvoo nnsoup-current-prefix 0)
  80. (defvoo nnsoup-replies-list nil)
  81. (defvoo nnsoup-buffers nil)
  82. (defvoo nnsoup-current-group nil)
  83. (defvoo nnsoup-group-alist-touched nil)
  84.  
  85.  
  86.  
  87. ;;; Interface functions.
  88.  
  89. (nnoo-define-basics nnsoup)
  90.  
  91. (deffoo nnsoup-retrieve-headers (sequence &optional group server fetch-old)
  92.   (nnsoup-possibly-change-group group)
  93.   (save-excursion
  94.     (set-buffer nntp-server-buffer)
  95.     (erase-buffer)
  96.     (let ((areas (cddr (assoc nnsoup-current-group nnsoup-group-alist)))
  97.       (articles sequence)
  98.       (use-nov t)
  99.       useful-areas this-area-seq msg-buf)
  100.       (if (stringp (car sequence))
  101.       ;; We don't support fetching by Message-ID.
  102.       'headers
  103.     ;; We go through all the areas and find which files the
  104.     ;; articles in SEQUENCE come from.
  105.     (while (and areas sequence)
  106.       ;; Peel off areas that are below sequence.
  107.       (while (and areas (< (cdaar areas) (car sequence)))
  108.         (setq areas (cdr areas)))
  109.       (when areas
  110.         ;; This is a useful area.
  111.         (push (car areas) useful-areas)
  112.         (setq this-area-seq nil)
  113.         ;; We take note whether this MSG has a corresponding IDX
  114.         ;; for later use.
  115.         (when (or (= (gnus-soup-encoding-index 
  116.               (gnus-soup-area-encoding (nth 1 (car areas)))) ?n)
  117.               (not (file-exists-p
  118.                 (nnsoup-file
  119.                  (gnus-soup-area-prefix (nth 1 (car areas)))))))
  120.           (setq use-nov nil))
  121.         ;; We assign the portion of `sequence' that is relevant to
  122.         ;; this MSG packet to this packet.
  123.         (while (and sequence (<= (car sequence) (cdaar areas)))
  124.           (push (car sequence) this-area-seq)
  125.           (setq sequence (cdr sequence)))
  126.         (setcar useful-areas (cons (nreverse this-area-seq)
  127.                        (car useful-areas)))))
  128.  
  129.     ;; We now have a list of article numbers and corresponding
  130.     ;; areas. 
  131.     (setq useful-areas (nreverse useful-areas))
  132.  
  133.     ;; Two different approaches depending on whether all the MSG
  134.     ;; files have corresponding IDX files.  If they all do, we
  135.     ;; simply return the relevant IDX files and let Gnus sort out
  136.     ;; what lines are relevant.  If some of the IDX files are
  137.     ;; missing, we must return HEADs for all the articles.
  138.     (if use-nov
  139.         ;; We have IDX files for all areas.
  140.         (progn
  141.           (while useful-areas
  142.         (goto-char (point-max))
  143.         (let ((b (point))
  144.               (number (car (nth 1 (car useful-areas))))
  145.               (index-buffer (nnsoup-index-buffer
  146.                      (gnus-soup-area-prefix
  147.                       (nth 2 (car useful-areas))))))
  148.           (when index-buffer
  149.             (insert-buffer-substring index-buffer)
  150.             (goto-char b)
  151.             ;; We have to remove the index number entires and
  152.             ;; insert article numbers instead.
  153.             (while (looking-at "[0-9]+")
  154.               (replace-match (int-to-string number) t t)
  155.               (incf number)
  156.               (forward-line 1))))
  157.         (setq useful-areas (cdr useful-areas)))
  158.           'nov)
  159.       ;; We insert HEADs.
  160.       (while useful-areas
  161.         (setq articles (caar useful-areas)
  162.           useful-areas (cdr useful-areas))
  163.         (while articles
  164.           (when (setq msg-buf
  165.               (nnsoup-narrow-to-article 
  166.                (car articles) (cdar useful-areas) 'head))
  167.         (goto-char (point-max))
  168.         (insert (format "221 %d Article retrieved.\n" (car articles)))
  169.         (insert-buffer-substring msg-buf)
  170.         (goto-char (point-max))
  171.         (insert ".\n"))
  172.           (setq articles (cdr articles))))
  173.  
  174.       (nnheader-fold-continuation-lines)
  175.       'headers)))))
  176.  
  177. (deffoo nnsoup-open-server (server &optional defs)
  178.   (nnoo-change-server 'nnsoup server defs)
  179.   (when (not (file-exists-p nnsoup-directory))
  180.     (condition-case ()
  181.     (make-directory nnsoup-directory t)
  182.       (error t)))
  183.   (cond 
  184.    ((not (file-exists-p nnsoup-directory))
  185.     (nnsoup-close-server)
  186.     (nnheader-report 'nnsoup "Couldn't create directory: %s" nnsoup-directory))
  187.    ((not (file-directory-p (file-truename nnsoup-directory)))
  188.     (nnsoup-close-server)
  189.     (nnheader-report 'nnsoup "Not a directory: %s" nnsoup-directory))
  190.    (t
  191.     (nnsoup-read-active-file)
  192.     (nnheader-report 'nnsoup "Opened server %s using directory %s"
  193.              server nnsoup-directory)
  194.     t)))
  195.  
  196. (deffoo nnsoup-request-close ()
  197.   (nnsoup-write-active-file)
  198.   (nnsoup-write-replies)
  199.   (gnus-soup-save-areas)
  200.   ;; Kill all nnsoup buffers.
  201.   (let (buffer)
  202.     (while nnsoup-buffers
  203.       (setq buffer (cdr (pop nnsoup-buffers)))
  204.       (and buffer
  205.        (buffer-name buffer)
  206.        (kill-buffer buffer))))
  207.   (setq nnsoup-group-alist nil
  208.     nnsoup-group-alist-touched nil
  209.     nnsoup-current-group nil
  210.     nnsoup-replies-list nil)
  211.   (nnoo-close-server 'nnoo)
  212.   t)
  213.  
  214. (deffoo nnsoup-request-article (id &optional newsgroup server buffer)
  215.   (nnsoup-possibly-change-group newsgroup)
  216.   (let (buf)
  217.     (save-excursion
  218.       (set-buffer (or buffer nntp-server-buffer))
  219.       (erase-buffer)
  220.       (when (and (not (stringp id))
  221.          (setq buf (nnsoup-narrow-to-article id)))
  222.     (insert-buffer-substring buf)
  223.     t))))
  224.  
  225. (deffoo nnsoup-request-group (group &optional server dont-check)
  226.   (nnsoup-possibly-change-group group)
  227.   (if dont-check 
  228.       t
  229.     (let ((active (cadr (assoc group nnsoup-group-alist))))
  230.       (if (not active)
  231.       (nnheader-report 'nnsoup "No such group: %s" group)
  232.     (nnheader-insert 
  233.      "211 %d %d %d %s\n" 
  234.      (max (1+ (- (cdr active) (car active))) 0) 
  235.      (car active) (cdr active) group)))))
  236.  
  237. (deffoo nnsoup-request-type (group &optional article)
  238.   (nnsoup-possibly-change-group group)
  239.   (if (not article)
  240.       'unknown
  241.     (let ((kind (gnus-soup-encoding-kind 
  242.          (gnus-soup-area-encoding
  243.           (nth 1 (nnsoup-article-to-area
  244.               article nnsoup-current-group))))))
  245.       (cond ((= kind ?m) 'mail)
  246.         ((= kind ?n) 'news)
  247.         (t 'unknown)))))
  248.  
  249. (deffoo nnsoup-close-group (group &optional server)
  250.   ;; Kill all nnsoup buffers.
  251.   (let ((buffers nnsoup-buffers)
  252.     elem)
  253.     (while buffers
  254.       (when (equal (car (setq elem (pop buffers))) group)
  255.     (setq nnsoup-buffers (delq elem nnsoup-buffers))
  256.     (and (cdr elem) (buffer-name (cdr elem))
  257.          (kill-buffer (cdr elem))))))
  258.   t)
  259.  
  260. (deffoo nnsoup-request-list (&optional server)
  261.   (save-excursion
  262.     (set-buffer nntp-server-buffer)
  263.     (erase-buffer)
  264.     (unless nnsoup-group-alist
  265.       (nnsoup-read-active-file))
  266.     (let ((alist nnsoup-group-alist)
  267.       (standard-output (current-buffer))
  268.       entry)
  269.       (while (setq entry (pop alist))
  270.     (insert (car entry) " ")
  271.     (princ (cdadr entry))
  272.     (insert " ")
  273.     (princ (caadr entry))
  274.     (insert " y\n"))
  275.       t)))
  276.  
  277. (deffoo nnsoup-request-scan (group &optional server)
  278.   (nnsoup-unpack-packets))
  279.  
  280. (deffoo nnsoup-request-newgroups (date &optional server)
  281.   (nnsoup-request-list))
  282.  
  283. (deffoo nnsoup-request-list-newsgroups (&optional server)
  284.   nil)
  285.  
  286. (deffoo nnsoup-request-post (&optional server)
  287.   (nnsoup-store-reply "news")
  288.   t)
  289.  
  290. (deffoo nnsoup-request-mail (&optional server)
  291.   (nnsoup-store-reply "mail")
  292.   t)
  293.  
  294. (deffoo nnsoup-request-expire-articles (articles group &optional server force)
  295.   (nnsoup-possibly-change-group group)
  296.   (let* ((total-infolist (assoc group nnsoup-group-alist))
  297.      (active (cadr total-infolist))
  298.      (infolist (cddr total-infolist))
  299.      info range-list mod-time prefix)
  300.     (while infolist
  301.       (setq info (pop infolist)
  302.         range-list (gnus-uncompress-range (car info))
  303.         prefix (gnus-soup-area-prefix (nth 1 info)))
  304.       (when ;; All the articles in this file are marked for expiry.
  305.       (and (or (setq mod-time (nth 5 (file-attributes
  306.                       (nnsoup-file prefix))))
  307.            (setq mod-time (nth 5 (file-attributes
  308.                       (nnsoup-file prefix t)))))
  309.            (gnus-sublist-p articles range-list)
  310.            ;; This file is old enough. 
  311.            (nnmail-expired-article-p group mod-time force))
  312.     ;; Ok, we delete this file.
  313.     (when (condition-case nil
  314.           (progn
  315.             (nnheader-message 
  316.              5 "Deleting %s in group %s..." (nnsoup-file prefix)
  317.              group)
  318.             (when (file-exists-p (nnsoup-file prefix))
  319.               (delete-file (nnsoup-file prefix)))
  320.             (nnheader-message 
  321.              5 "Deleting %s in group %s..." (nnsoup-file prefix t)
  322.              group)
  323.             (when (file-exists-p (nnsoup-file prefix t))
  324.               (delete-file (nnsoup-file prefix t)))
  325.             t)
  326.         (error nil))
  327.       (setcdr (cdr total-infolist) (delq info (cddr total-infolist)))
  328.       (setq articles (gnus-sorted-complement articles range-list))))
  329.       (when (not mod-time)
  330.     (setcdr (cdr total-infolist) (delq info (cddr total-infolist)))))
  331.     (if (cddr total-infolist)
  332.     (setcar active (caaadr (cdr total-infolist)))
  333.       (setcar active (1+ (cdr active))))
  334.     (nnsoup-write-active-file t)
  335.     ;; Return the articles that weren't expired.
  336.     articles))
  337.  
  338.  
  339. ;;; Internal functions
  340.  
  341. (defun nnsoup-possibly-change-group (group &optional force)
  342.   (if group
  343.       (setq nnsoup-current-group group)
  344.     t))
  345.  
  346. (defun nnsoup-read-active-file ()
  347.   (setq nnsoup-group-alist nil)
  348.   (when (file-exists-p nnsoup-active-file)
  349.     (condition-case ()
  350.     (load nnsoup-active-file t t t)
  351.       (error nil))
  352.     ;; Be backwards compatible.
  353.     (when (and nnsoup-group-alist
  354.            (not (atom (caadar nnsoup-group-alist))))
  355.       (let ((alist nnsoup-group-alist)
  356.         entry e min max)
  357.     (while (setq e (cdr (setq entry (pop alist))))
  358.       (setq min (caaar e))
  359.       (while (cdr e)
  360.         (setq e (cdr e)))
  361.       (setq max (cdaar e))
  362.       (setcdr entry (cons (cons min max) (cdr entry)))))
  363.       (setq nnsoup-group-alist-touched t))
  364.     nnsoup-group-alist))
  365.  
  366. (defun nnsoup-write-active-file (&optional force)
  367.   (when (and nnsoup-group-alist
  368.          (or force 
  369.          nnsoup-group-alist-touched))
  370.     (setq nnsoup-group-alist-touched nil)
  371.     (nnheader-temp-write nnsoup-active-file
  372.       (let ((standard-output (current-buffer)))
  373.     (prin1 `(setq nnsoup-group-alist ',nnsoup-group-alist))
  374.     (insert "\n")
  375.     (prin1 `(setq nnsoup-current-prefix ,nnsoup-current-prefix))
  376.     (insert "\n")))))
  377.  
  378. (defun nnsoup-next-prefix ()
  379.   "Return the next free prefix."
  380.   (let (prefix)
  381.     (while (or (file-exists-p 
  382.         (nnsoup-file (setq prefix (int-to-string
  383.                        nnsoup-current-prefix))))
  384.            (file-exists-p (nnsoup-file prefix t)))
  385.       (incf nnsoup-current-prefix))
  386.     (incf nnsoup-current-prefix)
  387.     prefix))
  388.  
  389. (defun nnsoup-read-areas ()
  390.   (save-excursion
  391.     (set-buffer nntp-server-buffer)
  392.     (let ((areas (gnus-soup-parse-areas (concat nnsoup-tmp-directory "AREAS")))
  393.       entry number area lnum cur-prefix file)
  394.       ;; Go through all areas in the new AREAS file.
  395.       (while (setq area (pop areas))
  396.     ;; Change the name to the permanent name and move the files.
  397.     (setq cur-prefix (nnsoup-next-prefix))
  398.     (message "Incorporating file %s..." cur-prefix)
  399.     (when (file-exists-p 
  400.            (setq file (concat nnsoup-tmp-directory
  401.                   (gnus-soup-area-prefix area) ".IDX")))
  402.       (rename-file file (nnsoup-file cur-prefix)))
  403.     (when (file-exists-p 
  404.            (setq file (concat nnsoup-tmp-directory 
  405.                   (gnus-soup-area-prefix area) ".MSG")))
  406.       (rename-file file (nnsoup-file cur-prefix t))
  407.       (gnus-soup-set-area-prefix area cur-prefix)
  408.       ;; Find the number of new articles in this area.
  409.       (setq number (nnsoup-number-of-articles area))
  410.       (if (not (setq entry (assoc (gnus-soup-area-name area)
  411.                       nnsoup-group-alist)))
  412.           ;; If this is a new area (group), we just add this info to
  413.           ;; the group alist. 
  414.           (push (list (gnus-soup-area-name area)
  415.               (cons 1 number)
  416.               (list (cons 1 number) area))
  417.             nnsoup-group-alist)
  418.         ;; There are already articles in this group, so we add this
  419.         ;; info to the end of the entry.
  420.         (nconc entry (list (list (cons (1+ (setq lnum (cdadr entry)))
  421.                        (+ lnum number))
  422.                      area)))
  423.         (setcdr (cadr entry) (+ lnum number))))))
  424.     (nnsoup-write-active-file t)
  425.     (delete-file (concat nnsoup-tmp-directory "AREAS"))))
  426.  
  427. (defun nnsoup-number-of-articles (area)
  428.   (save-excursion
  429.     (cond 
  430.      ;; If the number is in the area info, we just return it.
  431.      ((gnus-soup-area-number area)
  432.       (gnus-soup-area-number area))
  433.      ;; If there is an index file, we just count the lines.
  434.      ((/= (gnus-soup-encoding-index (gnus-soup-area-encoding area)) ?n)
  435.       (set-buffer (nnsoup-index-buffer (gnus-soup-area-prefix area)))
  436.       (count-lines (point-min) (point-max)))
  437.      ;; We do it the hard way - re-searching through the message
  438.      ;; buffer. 
  439.      (t
  440.       (set-buffer (nnsoup-message-buffer (gnus-soup-area-prefix area)))
  441.       (goto-char (point-min))
  442.       (let ((regexp (nnsoup-header (gnus-soup-encoding-format 
  443.                     (gnus-soup-area-encoding area))))
  444.         (num 0))
  445.     (while (re-search-forward regexp nil t)
  446.       (setq num (1+ num)))
  447.     num)))))
  448.  
  449. (defun nnsoup-index-buffer (prefix &optional message)
  450.   (let* ((file (concat prefix (if message ".MSG" ".IDX")))
  451.      (buffer-name (concat " *nnsoup " file "*")))
  452.     (or (get-buffer buffer-name)    ; File aready loaded.
  453.     (when (file-exists-p (concat nnsoup-directory file))
  454.       (save-excursion            ; Load the file.
  455.         (set-buffer (get-buffer-create buffer-name))
  456.         (buffer-disable-undo (current-buffer))
  457.         (push (cons nnsoup-current-group (current-buffer)) nnsoup-buffers)
  458.         (insert-file-contents (concat nnsoup-directory file))
  459.         (current-buffer))))))
  460.  
  461. (defun nnsoup-file (prefix &optional message)
  462.   (expand-file-name
  463.    (concat nnsoup-directory prefix (if message ".MSG" ".IDX"))))
  464.  
  465. (defun nnsoup-message-buffer (prefix)
  466.   (nnsoup-index-buffer prefix 'msg))
  467.  
  468. (defun nnsoup-unpack-packets ()
  469.   "Unpack all packets in `nnsoup-packet-directory'."
  470.   (let ((packets (directory-files
  471.           nnsoup-packet-directory t nnsoup-packet-regexp))
  472.     packet)
  473.     (while (setq packet (pop packets))
  474.       (message (format "nnsoup: unpacking %s..." packet))
  475.       (if (not (gnus-soup-unpack-packet 
  476.         nnsoup-tmp-directory nnsoup-unpacker packet))
  477.       (message "Couldn't unpack %s" packet)
  478.     (delete-file packet)
  479.     (nnsoup-read-areas)
  480.     (message "Unpacking...done")))))
  481.  
  482. (defun nnsoup-narrow-to-article (article &optional area head)
  483.   (let* ((area (or area (nnsoup-article-to-area article nnsoup-current-group)))
  484.      (prefix (and area (gnus-soup-area-prefix (nth 1 area))))
  485.      (msg-buf (and prefix (nnsoup-index-buffer prefix 'msg)))
  486.      beg end)
  487.     (when area
  488.       (save-excursion
  489.     (cond
  490.      ;; There is no MSG file.
  491.      ((null msg-buf)
  492.       nil)
  493.        
  494.      ;; We use the index file to find out where the article begins and ends. 
  495.      ((and (= (gnus-soup-encoding-index 
  496.            (gnus-soup-area-encoding (nth 1 area)))
  497.           ?c)
  498.            (file-exists-p (nnsoup-file prefix)))
  499.       (set-buffer (nnsoup-index-buffer prefix))
  500.       (widen)
  501.       (goto-char (point-min))
  502.       (forward-line (- article (caar area)))
  503.       (setq beg (read (current-buffer)))
  504.       (forward-line 1)
  505.       (if (looking-at "[0-9]+")
  506.           (progn
  507.         (setq end (read (current-buffer)))
  508.         (set-buffer msg-buf)
  509.         (widen)
  510.         (let ((format (gnus-soup-encoding-format
  511.                    (gnus-soup-area-encoding (nth 1 area)))))
  512.           (goto-char end)
  513.           (if (or (= format ?n) (= format ?m))
  514.               (setq end (progn (forward-line -1) (point))))))
  515.         (set-buffer msg-buf))
  516.       (widen)
  517.       (narrow-to-region beg (or end (point-max))))
  518.      (t
  519.       (set-buffer msg-buf)
  520.       (widen)
  521.       (goto-char (point-min))
  522.       (let ((header (nnsoup-header 
  523.              (gnus-soup-encoding-format 
  524.               (gnus-soup-area-encoding (nth 1 area))))))
  525.         (re-search-forward header nil t (- article (caar area)))
  526.         (narrow-to-region
  527.          (match-beginning 0)
  528.          (if (re-search-forward header nil t)
  529.          (match-beginning 0)
  530.            (point-max))))))
  531.     (goto-char (point-min))
  532.     (if (not head)
  533.         ()
  534.       (narrow-to-region
  535.        (point-min)
  536.        (if (search-forward "\n\n" nil t)
  537.            (1- (point))
  538.          (point-max))))
  539.     msg-buf))))
  540.  
  541. (defun nnsoup-header (format)
  542.   (cond 
  543.    ((= format ?n)
  544.     "^#! *rnews +[0-9]+ *$")
  545.    ((= format ?m)
  546.     (concat "^" message-unix-mail-delimiter))
  547.    ((= format ?M)
  548.     "^\^A\^A\^A\^A\n")
  549.    (t
  550.     (error "Unknown format: %c" format))))
  551.  
  552. ;;;###autoload
  553. (defun nnsoup-pack-replies ()
  554.   "Make an outbound package of SOUP replies."
  555.   (interactive)
  556.   ;; Write all data buffers.
  557.   (gnus-soup-save-areas)
  558.   ;; Write the active file.
  559.   (nnsoup-write-active-file)
  560.   ;; Write the REPLIES file.
  561.   (nnsoup-write-replies)
  562.   ;; Pack all these files into a SOUP packet.
  563.   (gnus-soup-pack nnsoup-replies-directory nnsoup-packer))
  564.  
  565. (defun nnsoup-write-replies ()
  566.   "Write the REPLIES file."
  567.   (when nnsoup-replies-list
  568.     (gnus-soup-write-replies nnsoup-replies-directory nnsoup-replies-list)
  569.     (setq nnsoup-replies-list nil)))
  570.  
  571. (defun nnsoup-article-to-area (article group)
  572.   "Return the area that ARTICLE in GROUP is located in."
  573.   (let ((areas (cddr (assoc group nnsoup-group-alist))))
  574.     (while (and areas (< (cdaar areas) article))
  575.       (setq areas (cdr areas)))
  576.     (and areas (car areas))))
  577.  
  578. (defvar nnsoup-old-functions
  579.   (list message-send-mail-function message-send-news-function))
  580.  
  581. ;;;###autoload
  582. (defun nnsoup-set-variables ()
  583.   "Use the SOUP methods for posting news and mailing mail."
  584.   (interactive)
  585.   (setq message-send-news-function 'nnsoup-request-post)
  586.   (setq message-send-mail-function 'nnsoup-request-mail))
  587.  
  588. ;;;###autoload
  589. (defun nnsoup-revert-variables ()
  590.   "Revert posting and mailing methods to the standard Emacs methods."
  591.   (interactive)
  592.   (setq message-send-mail-function (car nnsoup-old-functions))
  593.   (setq message-send-news-function (cadr nnsoup-old-functions)))
  594.  
  595. (defun nnsoup-store-reply (kind)
  596.   ;; Mostly stolen from `message.el'.
  597.   (require 'mail-utils)
  598.   (let ((tembuf (generate-new-buffer " message temp"))
  599.     (case-fold-search nil)
  600.     (news (message-news-p))
  601.     (resend-to-addresses (mail-fetch-field "resent-to"))
  602.     delimline
  603.     (mailbuf (current-buffer)))
  604.     (unwind-protect
  605.     (save-excursion
  606.       (save-restriction
  607.         (message-narrow-to-headers)
  608.         (if (equal kind "mail")
  609.         (message-generate-headers message-required-mail-headers)
  610.           (message-generate-headers message-required-news-headers)))
  611.       (set-buffer tembuf)
  612.       (erase-buffer)
  613.       (insert-buffer-substring mailbuf)
  614.       ;; Remove some headers.
  615.       (save-restriction
  616.         (message-narrow-to-headers)
  617.         ;; Remove some headers.
  618.         (message-remove-header message-ignored-mail-headers t))
  619.       (goto-char (point-max))
  620.       ;; require one newline at the end.
  621.       (or (= (preceding-char) ?\n)
  622.           (insert ?\n))
  623.       (when (and news
  624.              (equal kind "mail")
  625.              (or (mail-fetch-field "cc")
  626.              (mail-fetch-field "to")))
  627.         (message-insert-courtesy-copy))
  628.       (let ((case-fold-search t))
  629.         ;; Change header-delimiter to be what sendmail expects.
  630.         (goto-char (point-min))
  631.         (re-search-forward
  632.          (concat "^" (regexp-quote mail-header-separator) "\n"))
  633.         (replace-match "\n")
  634.         (backward-char 1)
  635.         (setq delimline (point-marker))
  636.         ;; Insert an extra newline if we need it to work around
  637.         ;; Sun's bug that swallows newlines.
  638.         (goto-char (1+ delimline))
  639.         (when (eval message-mailer-swallows-blank-line)
  640.           (newline))
  641.         (let ((msg-buf
  642.            (gnus-soup-store 
  643.             nnsoup-replies-directory 
  644.             (nnsoup-kind-to-prefix kind) nil nnsoup-replies-format-type
  645.             nnsoup-replies-index-type))
  646.           (num 0))
  647.           (when (and msg-buf (bufferp msg-buf))
  648.         (save-excursion
  649.           (set-buffer msg-buf)
  650.           (goto-char (point-min))
  651.           (while (re-search-forward "^#! *rnews" nil t)
  652.             (incf num)))
  653.         (message "Stored %d messages" num)))
  654.         (nnsoup-write-replies)
  655.         (kill-buffer tembuf))))))
  656.  
  657. (defun nnsoup-kind-to-prefix (kind)
  658.   (unless nnsoup-replies-list
  659.     (setq nnsoup-replies-list
  660.       (gnus-soup-parse-replies 
  661.        (concat nnsoup-replies-directory "REPLIES"))))
  662.   (let ((replies nnsoup-replies-list))
  663.     (while (and replies 
  664.         (not (string= kind (gnus-soup-reply-kind (car replies)))))
  665.       (setq replies (cdr replies)))
  666.     (if replies
  667.     (gnus-soup-reply-prefix (car replies))
  668.       (setq nnsoup-replies-list
  669.         (cons (vector (gnus-soup-unique-prefix nnsoup-replies-directory)
  670.               kind 
  671.               (format "%c%c%c"
  672.                   nnsoup-replies-format-type
  673.                   nnsoup-replies-index-type
  674.                   (if (string= kind "news")
  675.                       ?n ?m)))
  676.           nnsoup-replies-list))
  677.       (gnus-soup-reply-prefix (car nnsoup-replies-list)))))
  678.  
  679. (defun nnsoup-make-active ()
  680.   "(Re-)create the SOUP active file."
  681.   (interactive)
  682.   (let ((files (sort (directory-files nnsoup-directory t "IDX$")
  683.              (lambda (f1 f2)
  684.                (< (progn (string-match "/\\([0-9]+\\)\\." f1)
  685.                  (string-to-int (match-string 1 f1)))
  686.               (progn (string-match "/\\([0-9]+\\)\\." f2)
  687.                  (string-to-int (match-string 1 f2)))))))
  688.     active group lines ident elem min)
  689.     (set-buffer (get-buffer-create " *nnsoup work*"))
  690.     (buffer-disable-undo (current-buffer))
  691.     (while files
  692.       (message "Doing %s..." (car files))
  693.       (erase-buffer)
  694.       (insert-file-contents (car files))
  695.       (goto-char (point-min))
  696.       (if (not (re-search-forward "^[^\t]*\t[^\t]*\t[^\t]*\t[^\t]*\t[^\t]*\t[^\t]*\t[^\t]*\t[^\t]*\t *\\(Xref: \\)? *[^ ]* \\([^ ]+\\):[0-9]" nil t))
  697.       (setq group "unknown")
  698.     (setq group (match-string 2)))
  699.       (setq lines (count-lines (point-min) (point-max)))
  700.       (setq ident (progn (string-match
  701.               "/\\([0-9]+\\)\\." (car files))
  702.              (substring 
  703.               (car files) (match-beginning 1)
  704.               (match-end 1))))
  705.       (if (not (setq elem (assoc group active)))
  706.       (push (list group (cons 1 lines)
  707.               (list (cons 1 lines) 
  708.                 (vector ident group "ncm" "" lines)))
  709.         active)
  710.     (nconc elem
  711.            (list
  712.         (list (cons (1+ (setq min (cdadr elem)))
  713.                 (+ min lines))
  714.               (vector ident group "ncm" "" lines))))
  715.     (setcdr (cadr elem) (+ min lines)))
  716.       (setq files (cdr files)))
  717.     (message "")
  718.     (setq nnsoup-group-alist active)
  719.     (nnsoup-write-active-file t)))
  720.  
  721. (defun nnsoup-delete-unreferenced-message-files ()
  722.   "Delete any *.MSG and *.IDX files that aren't known by nnsoup."
  723.   (interactive)
  724.   (let* ((known (apply 'nconc (mapcar 
  725.                    (lambda (ga)
  726.                  (mapcar
  727.                   (lambda (area)
  728.                     (gnus-soup-area-prefix (cadr area)))
  729.                   (cddr ga)))
  730.                    nnsoup-group-alist)))
  731.      (regexp "\\.MSG$\\|\\.IDX$")
  732.      (files (directory-files nnsoup-directory nil regexp))
  733.      non-files file)
  734.     ;; Find all files that aren't known by nnsoup.
  735.     (while (setq file (pop files))
  736.       (string-match regexp file)
  737.       (unless (member (substring file 0 (match-beginning 0)) known)
  738.     (push file non-files)))
  739.     ;; Sort and delete the files.
  740.     (setq non-files (sort non-files 'string<))
  741.     (map-y-or-n-p "Delete file %s? "
  742.           (lambda (file) (delete-file (concat nnsoup-directory file)))
  743.           non-files)))
  744.  
  745. (provide 'nnsoup)
  746.  
  747. ;;; nnsoup.el ends here
  748.